home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1995 January / macformat-020.iso / Shareware City / Applications / Alpha.5.96 folder / Tcl / SystemCode / procs.tcl < prev    next >
Encoding:
Text File  |  1994-09-20  |  16.1 KB  |  669 lines  |  [TEXT/ALFA]
  1. #==============================================================================
  2. proc normalLeftBracket {} {
  3.     insertText "\{"
  4. }
  5. proc normalRightBracket {} {
  6.     insertText "\}"
  7. }
  8. bind '\[' <zs>  normalLeftBracket
  9. bind '\]' <zs>  normalRightBracket
  10.             
  11. # Select the next or current word. If word already selected, will go to next.
  12. proc hiliteWord {} {
  13.     if {[getPos]!=[selEnd]}    forwardChar
  14.     forwardWord
  15.     set start [getPos]
  16.     backwardWord
  17.     select $start [getPos]
  18. }
  19.  
  20. bind 'h' <z> hiliteWord
  21.  
  22. #================================================================================
  23. # Mode variables
  24. #================================================================================
  25. # For mark stack.
  26. set markName 0
  27. set markStack ""
  28.  
  29. # mapping of windows to current modes.
  30. set winModes("") ""
  31.  
  32. # making vars local to windows
  33. # 'incomingVars' used to hold old var values that have been overwritten in current window
  34.  
  35. #================================================================================
  36. # Handle 'flag' and 'var' menu selections.
  37. #================================================================================
  38. proc editFlag {menu item} {
  39.     global $item incomingVars localVars modifiedVars
  40.  
  41.     lappend modifiedVars $item
  42.     set val [expr ([set $item]-1)*-1]
  43.     markMenuItem $menu $item [expr ($val)?"on":"off"]
  44.     set $item $val
  45.  
  46. }
  47.  
  48. proc editVar {menu item} {
  49.     global $item incomingVars localVars modifiedVars
  50.  
  51.     lappend modifiedVars $item
  52.     append prmpt "New Value of " $item ": "
  53.     if ![catch {prompt $prmpt [set $item]} res] {
  54.         set $item $res
  55.     }
  56. }
  57.  
  58.  
  59.  
  60.  
  61. #================================================================================
  62.  
  63. # Instantiate a global variable to the path of a file (usually an app). As a
  64. # side-effect, make the instantiation permanent by adding a line to 'definitions.tcl'.
  65. proc addAppPath {name var} {
  66.     global $var
  67.     
  68.     if {[catch {getfile "Find '$name' app:"} path]} {return 1}
  69.     set $var $path
  70.  
  71.     addUserLine "set $var \"[quoteExpr2 $path]\""
  72.     return 0
  73. }
  74.  
  75. proc addUserLine {line} {
  76.     global HOME
  77.  
  78.     if {[file exists "$HOME:userStartup.tcl"]} {
  79.         set fid [open "$HOME:userStartup.tcl" "a"]
  80.     } else {
  81.         set fid [open "$HOME:userStartup.tcl" "w"]
  82.     }
  83.     puts $fid $line
  84.     close $fid
  85. }
  86.  
  87.  
  88. proc addAlphabitsLine {line} {
  89.     global HOME
  90.  
  91.     set fid [open "$HOME:Tcl:SystemCode:AlphaBits.tcl" "a"]
  92.     puts $fid $line
  93.     close $fid
  94. }
  95.  
  96.  
  97. proc getFileSig {f} {
  98.     catch {lindex [ls -l $f] 6} var
  99.     return $var
  100. }
  101.  
  102.  
  103. # Look for given app sig in active processes. If not there, try to 
  104. # launch with 'path' prompting for 'path' if necessary.
  105. # Return the real name of the app. Don't switch.
  106. proc checkRunning {name sig path} {
  107.     global $path
  108.     foreach proc [processes] {
  109.         if {[lindex $proc 1] == $sig} {
  110.             return [lindex $proc 0]
  111.         }
  112.     }
  113.     if {![info exists $path] || ![file exists [set $path]]} {
  114.         if {[addAppPath $name $path]} return
  115.     }
  116.     if {[catch {getFileSig [set $path]}]} {
  117.         if {[addAppPath $name $path]} return
  118.     }
  119.     set sig [getFileSig [set $path]]
  120.     if {[catch {launch -f [set $path]}]} {
  121.         error "Problem with launching file (out of memory?)"
  122.     }
  123.     return [file tail [set $path]]
  124. #    return [checkRunning $name $sig $path]
  125. }
  126.  
  127. #================================================================================
  128. # Excalibur is the only Mac spell-checker that I know of which will handle LaTeX as
  129. # well as ordinary text.
  130.  
  131.  
  132. proc spellcheckWindow {} {
  133.     global excaliburPath resumeRevert
  134.  
  135.     catch {checkRunning Excalibur XCLB excaliburPath} name
  136.  
  137.     if {[winInfo dirty]} {
  138.         if {[askyesno "Save '[lindex [winNames] 0]'?"] == "yes"} {
  139.             save
  140.         }
  141.     }
  142.     if {[catch {sendOpenEvent -n $name [lindex [winNames -f] 0]}] } {
  143.         beep 
  144.     } else {
  145.         switchTo $name
  146.     }
  147.     set resumeRevert 1
  148. }
  149.  
  150. proc spellcheckSelection {} {
  151.     global excaliburPath 
  152.  
  153.     catch {checkRunning Excalibur XCLB excaliburPath} name
  154.  
  155.     if {[getPos] == [selEnd]} {
  156.         beep
  157.         message "No selection"
  158.         return;
  159.     }
  160.     copy
  161.     switchTo $name
  162. }
  163.  
  164. #================================================================================
  165.  
  166.  
  167. proc alphaHelp {} {
  168.     global HOME winModes
  169.     edit -r "$HOME:Help:Intro"
  170. }
  171.  
  172.  
  173. proc tclHelp {} {
  174.     global HOME
  175.     edit -r "$HOME:Help:Tcl Commands"
  176. }
  177.  
  178.  
  179. set patternLibrary {
  180.     { "Pascal to C Comments" {        \{([^\}]*)\}} {/* \1 */} }
  181.     { "C++ to C Comments" {//(.*)} {/* \1 */}}
  182. }
  183.  
  184.  
  185. proc dividingLine {} {
  186.     insertText "================================================================================\r"
  187. }
  188. bind 'l' <C> dividingLine
  189.  
  190. proc texDividingLine {} {
  191.     insertText "%================================================================================\r"
  192. }
  193. bind 'l' <C> texDividingLine TeX
  194.  
  195. proc cDividingLine {} {
  196.     insertText "//================================================================================\r"
  197. }
  198. bind 'l' <C> cDividingLine C
  199. bind 'l' <C> cDividingLine C++
  200.  
  201. proc tclDividingLine {} {
  202.     insertText "#================================================================================\r"
  203. }
  204. bind 'l' <C> tclDividingLine Tcl
  205.  
  206.  
  207. #================================================================================
  208.  
  209. if {![string length [info commands oldCd]]} {
  210.     rename cd oldCd
  211. }
  212.  
  213. proc cd args {
  214.     global HOME
  215.     if {[llength $args]} {
  216.         oldCd [string trim [eval list $args] "        \{\}"]
  217.     } else {
  218.         oldCd $HOME
  219.     }
  220. }
  221.  
  222.  
  223.  
  224. #############################################################################
  225. #  List the name and value of each element of the array $arrName.
  226. #  (Convenient to use as a shell command.)
  227. #
  228. #  Note: it's slower to insert the lines one-by-one like this, but 
  229. #  assembling everything in $lines before inserting can seriously crash Alpha
  230. #  if the result is too big.  (Trying to list the contents of $auto_index()
  231. #  will do it.)  This method seems to be more robust.
  232. #
  233. proc listArray {arrName} {
  234.     global $arrName
  235.     set lines {}
  236.     if {![catch {info vars $arrName}]} {
  237.         foreach nm [array names $arrName] {
  238.             set val [expr \$$arrName\($nm\)]
  239.             append lines "\r\"$nm\"\t\{$val\}"
  240.         }
  241.         insertText $lines
  242.     } else {
  243.         alertnote "\"$arrName\" doesn't exist in this context"
  244.     }
  245. }
  246.  
  247.  
  248.  
  249. #================================================================================
  250.     
  251. proc selectParagraph {} {
  252.     set pos [getPos]
  253.     set start [paraStart $pos] 
  254.     set finish [paraFinish $pos]
  255.     goto $start
  256.     select $start $finish
  257. }
  258.  
  259. # wrapText ==  getText ; breakIntoLines ; replaceText
  260. # Remove text from window, transform (join, del-ws), insert back into window.
  261. proc fillTextByPar {from to} {
  262.     set text [getText $from $to]
  263.     regsub -all "\r(\[ \t\]*\r)+" $text "\r\r\r" text
  264.     regsub -all "(\[^\r\])\r" $text "\\1 " text
  265.     regsub -all "\[ \t\]+" $text " " text
  266.     return [breakIntoLines $text]
  267. }
  268.  
  269. proc fillRegionByPar {{start -1} {finish -1}} {
  270. #    # if {[getPos] == [selEnd]} { return}
  271.     if {($start < 0) || ($finish < 0)} {
  272.         set start [lineStart [getPos]]
  273.         set finish [selEnd] }
  274.     if {$start >= $finish} return
  275.     goto $start
  276.     set text [fillTextByPar $start $finish]
  277.     replaceText $start $finish $text "\r"
  278. }
  279.     
  280. #
  281. # join Lines in region -- if no optional args, use selection
  282. #
  283. proc joinRegion {{from -1} {to -1}} {
  284.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  285.     if {$from >= $to} return
  286.     set text [getText $from $to]
  287.     regsub -all "\r(\[ \t\]*\r)+" $text "\r\r\r" text
  288.     regsub -all "(\[^\r\])\r" $text "\\1 " text
  289.     replaceText $from $to $text "\r"
  290. }
  291. # WARNING:    regsub ^$ refers to string endpts (not lines)
  292. # FUTURE:    filterLines like perl:
  293. #    replaceText[apply_to_all(cmd,split [getText [getPos] [selEnd]] "\r")]
  294. # OR:    replaceInRegion: dup_\r, $=>\r ??
  295. #
  296.  
  297.  
  298. #
  299. # Remove text from window, transform (delete dup ws), insert back into window.
  300. #
  301. # inputs: message, alertnote, askyesno, listpick, prompt KILLS SELECTION.
  302. # search: bnds = search -forward -regExpr -ignoreCase -matchWords -noabort 
  303. #        -l limit pat pos
  304. # 
  305. proc regsubInRegion {from to srch repl} {
  306.     if {![string length $srch]} return
  307.     if {$from >= $to} return
  308.     set text [getText $from $to]
  309.     regsub -all "$srch" $text "$repl" text
  310.     replaceText $from $to $text
  311. }
  312. #    while {($pos < $to) &&
  313. #          ![catch {search -f 1 -r 1 -i 1 -m 0 "$srch" $pos} mtch]} {
  314. #        set mbeg [lindex $mtch 0]
  315. #        set pos [lindex $mtch 1]
  316. #        replaceText $mbeg $pos $repl }
  317.  
  318. #proc backSlashSub {arg} { eval [concat return "\"$arg\""] }
  319.  
  320. proc backSlashSub {arg} {
  321.     regsub -all {\\} $arg {\\\\} arg
  322.     regsub -all {\[} $arg {\\[} arg
  323.     regsub -all {\]} $arg {\\]} arg
  324.     eval [concat return "\"$arg\""]
  325. }
  326.  
  327. proc replaceInRegion {} {
  328.     if [catch {prompt "Search RegExpr:" ""} srch] return
  329.     if [catch {prompt "Replace String:" ""} repl] return
  330.     if {![string length $srch]} return
  331.     regsubInRegion [getPos] [selEnd] \
  332.         [backSlashSub "$srch"] [backSlashSub "$repl"]
  333. }
  334.  
  335. #
  336. # Apply command to each line (or paragraph) in selection ;
  337. #    if no cmd arg then prompts for it
  338. #
  339. proc filterLines {{cmd 0} {parunit 0}} {
  340.     if {$cmd == 0} {
  341.       if {[catch { prompt "Line-filter command: " "" } cmd]} { return } }
  342.     if {![string length $cmd]} return
  343.     set unitStart lineStart
  344.     set unitEnd nextLineStart
  345.     if {$parunit} {
  346.         set unitStart paraStart
  347.         set unitEnd paraFinish }
  348.     set pos [$unitStart [getPos]]
  349.     set finish [selEnd]
  350.     if {$pos >= $finish} return
  351.     goto $pos
  352.     createTMark "filterLend" $finish
  353.     set next [$unitEnd $pos]
  354.     while {(($next > $pos) && ($pos < $finish))} {
  355.         goto [expr $next-1]
  356.         createTMark "filterLnext" $next
  357.         setMark
  358.         goto $pos
  359.         markHilite
  360.         if {[catch [list uplevel #0 "$cmd"] retval]} {
  361.             select $pos $finish
  362.             alertnote $retval
  363.             return
  364.         }
  365.         if {$next==$finish} break
  366.         set ind [lsearch -regexp [lindex [getTMarks] 0] "filterLend.*"]
  367.         set finish [lindex [lindex [lindex [getTMarks] 0] $ind] 2]
  368.         gotoTMark "filterLnext"
  369.         set pos [$unitStart [getPos]]
  370.         set next [$unitEnd $pos]
  371.     }
  372.     removeTMark "filterLend"
  373.     removeTMark "filterLnext"
  374. }
  375.  
  376.  
  377. proc filterParagraphs {{cmd 0}} { filterLines $cmd 1 }
  378.  
  379. # WARNING: deselecting sets the mark to selEnd
  380. proc sortParagraphs {{from -1} {to -1}} {
  381.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  382.     if {$from >= $to} return
  383.     joinRegion {$from $to}
  384.     select [getPos] [nextLineStart [getMark]]
  385.     sortLines
  386.     select [getPos] [getPos]
  387.     regsubInRegion [getPos] [getMark] "\r" "\r\r" 
  388.     wrapRegion
  389. }
  390.  
  391. #
  392. # Sample
  393. #
  394. proc filterRegion {{from -1} {to -1} {cmd 0} {newwin 0}} {
  395.     if {$cmd == 0} {
  396.       if {[catch { prompt "Eval command: " "" } cmd]} { return }
  397.     }
  398.     if {![string length $cmd]} return
  399.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  400.     if {$from >= $to} return
  401.     set pos [getPos]
  402.     set text [getText $from $to]
  403.     set text [$cmd $text]
  404.     replaceText $from $to $text "\r"
  405.     goto $pos
  406. }
  407.  
  408.  
  409. #
  410. set lastEvaled ""
  411. proc evaluate {} {
  412.     global lastEvaled
  413.     if {[string length $lastEvaled]} {
  414.         set p "M-x ($lastEvaled): "
  415.     } else {
  416.         set p "M-x: "
  417.     }
  418.     if {[catch {statusPrompt $p} text]} {return}
  419.     if {![string length $text]} {set text $lastEvaled}
  420.     $text
  421.     set lastEvaled $text
  422. }
  423.  
  424.  
  425. # First, define macros to bypass the electric braces.
  426. proc ordLeftBrace {} {
  427.     insertText "        \{"
  428. }
  429. bind {'['} <cs> ordLeftBrace
  430.  
  431. proc ordRightBrace {} {
  432.     insertText "\}"
  433.     blink [matchIt "\}" [expr [getPos]-1]]
  434. }
  435. bind {']'} <cs> ordRightBrace
  436.     
  437. proc quoteWord {} {
  438.     backwardWord
  439.     insertText "'"
  440.     forwardWord
  441.     insertText "'"
  442. }
  443. bind ''' <z> quoteWord
  444.  
  445. #================================================================================
  446.  
  447. proc tomac {fname} {
  448.     set fd [open $fname "r"]
  449.     set text [read $fd]
  450.     close $fd
  451.     set fd [open $fname "w"]
  452.     regsub "\n" $text "\r" text
  453.     puts -nonewline $fd $text
  454.     close $fd
  455. }
  456.  
  457. proc tounix {fname} {
  458.     set fd [open $fname "r"]
  459.     set text [read $fd]
  460.     close $fd
  461.     set fd [open $fname "w"]
  462.     regsub "\r" $text "\n" text
  463.     puts -nonewline $fd $text
  464.     close $fd
  465. }
  466.  
  467.  
  468. proc cat args {
  469.     set files ""
  470.     foreach a $args {
  471.         foreach f [glob $a] {
  472.             lappend files $f
  473.         }
  474.     }
  475.     foreach f $files {
  476.         append text "==============<$f>==============\r"
  477.         set fd [open $f "r"]
  478.         append text "[read $fd]\r\r"
  479.         close $fd
  480.     }
  481.     return $text
  482. }
  483.  
  484. proc catto args {
  485.     set len [llength $args]
  486.     set to [lindex $args [expr $len -1]]
  487.     set args [lrange $args 0 [expr $len -2]]
  488.  
  489.     set files ""
  490.     foreach a $args {
  491.         foreach f [glob $a] {
  492.             lappend files $f
  493.         }
  494.     }
  495.     foreach f $files {
  496.         append text "==============<$f>==============\r"
  497.         set fd [open $f "r"]
  498.         append text "[read $fd]\r\r"
  499.         close $fd
  500.     }
  501.  
  502.     set dfile $to
  503.     if {[file exists $dfile]} {
  504.         set fid [open $dfile "a"]
  505.     } else {
  506.         set fid [open $dfile "w"]
  507.     }
  508.     puts $fid $text
  509.     close $fid
  510. }
  511.  
  512.  
  513. ##############################################################################
  514. #  To be used in the windows created by "matchingLines" or by batch searches.
  515. #
  516. #  With the cursor positioned in a line corrsponding to a match, 
  517. #  go back and select the line in the original file that 
  518. #  generated this match.  (Like emacs 'Occur' functionality)
  519. #
  520. proc gotoMatch {} {
  521.     set text [getText [lineStart [getPos]] [expr [nextLineStart [getPos]] - 1]]
  522.     set ind1 [string first "∞" $text]
  523.     set ind2 [string last "∞" $text]
  524.     if {$ind1 == $ind2} {
  525.         set fname [string trim [string range $text $ind1 end] {∞}]
  526.         set msg ""
  527.     } else {
  528.         set fname [string trim [string range $text $ind1 $ind2] {∞}]
  529.         set msg [string trim [string range $text $ind2 end] {∞}]
  530.     }
  531.     if {[expr {[lsearch [winNames -f] "*$fname"] >= 0}]} {
  532.         bringToFront $fname
  533.     } elseif {[file exists $fname]} {
  534.         edit $fname
  535.     } else {
  536.         alertnote "File \" $fname \" not found." ; return
  537.     }
  538.     if {![regexp {Line ([0-9]+):} $text dummy line]} { error "Garbage" }
  539.     goto [rowColToPos $line 0]
  540.     message $msg
  541. }
  542. bind 'c' <Cz>        gotoMatch
  543.  
  544.  
  545. #================================================================================
  546.  
  547. proc prevIntro {} {
  548.     set res [search -f 0 -r 0 {== } [getPos]]
  549.     display [lineStart [expr [lineStart [lindex $res 0]] - 1]]
  550. }
  551.  
  552. proc nextIntro {} {
  553.     set res [search -f 1 -r 0 {== } [getPos]]
  554.     set res [lindex $res 1]
  555.     set res [search -f 1 -r 0 {== } $res]
  556.     display [lineStart [expr [lineStart [lindex $res 0]] - 1]]
  557. }
  558.  
  559. #================================================================================
  560.  
  561. proc searchStart {} {
  562.     global search_start
  563.     select [getPos]
  564.     setMark
  565.     if {[catch {goto $search_start}]} {message "No previous search"}
  566. }
  567.  
  568. #================================================================================
  569.  
  570.  
  571. proc listBindings {} {
  572.     new -n {* Key Bindings *}
  573.     insertText [bindingList]
  574.  
  575.     global infoWindowsDirty
  576.     if {!$infoWindowsDirty} {setWinInfo dirty 0}
  577. }
  578.  
  579.  
  580. #================================================================================
  581.  
  582. proc printArray {arr} {
  583.     global $arr
  584.         foreach n [array names $arr] {
  585.         append text "$n '[set ${arr}($n)]'\r"
  586.     }
  587.     return [string trim $text "\r"]
  588. }
  589.  
  590. #================================================================================
  591.  
  592.  
  593. proc doATab {} {
  594.     global electricTab
  595.     if {!$electricTab || [regexp {[^ \t]} [getText [lineStart [getPos]] [getPos]]]} {
  596.         if {[getPos] != [selEnd]} {
  597.             replaceText [getPos] [selEnd] "\t"
  598.         } else {
  599.             insertText "\t"
  600.         }
  601.     } else {
  602.         indentLine
  603.     }
  604. }
  605.  
  606. #     set ptext [getText [lindex $lst 0] [nextLineStart [lindex $lst 0]]]
  607. #     regsub -all {[^(]} $ptext {} one
  608. #     regsub -all {[^)]} $ptext {} two
  609. #     if {[string length $one] > [string length $two]} {
  610. #         regexp {[^(]*\(} $ptext blah
  611. #         regsub -all {[^    ]} $blah { } lwhite
  612. #     } elseif {($nextC == "\{")} {
  613. #         append lwhite "\t"
  614. #     }
  615.  
  616. proc indentLine {} {
  617.     set beg [lineStart [getPos]]
  618.  
  619.     set lst [search -s -f 0 -r 1 -i 0 {^[ \t]*[^ \t\r]} [expr $beg-1]]
  620.     set lwhite [getText [lindex $lst 0] [expr [lindex $lst 1] - 1]]
  621.     set nextC [lookAt [expr [nextLineStart [lindex $lst 1]] - 2]]
  622.  
  623.     if {($nextC == "\{")} {
  624.         append lwhite "\t"
  625.     }
  626.     set text [getText $beg [nextLineStart $beg]]
  627.     regexp {^[ \t]*} $text white
  628.     set len [string length $white]
  629.     set nextC [lookAt [expr $beg + $len]]
  630.     if {$nextC == "\}"} {
  631.         set lwhite [string range $lwhite 0 [expr [string length $lwhite] - 2]]
  632.     }
  633.     
  634.     if {$white != $lwhite} {
  635.         replaceText $beg [expr $beg + $len] $lwhite
  636.     }
  637.     goto [expr $beg + [string length $lwhite]]
  638. }
  639.  
  640.  
  641. proc indentRegion {} {
  642.     set from [lindex [posToRowCol [getPos]] 0]
  643.     set to [lindex [posToRowCol [selEnd]] 0]
  644.     select [getPos]
  645.     while {$from <= $to} {
  646.         goto [rowColToPos $from 0]
  647.         indentLine
  648.         incr from
  649.     }
  650. }
  651.  
  652. #================================================================================
  653.  
  654. proc sPrompt {msg def} {
  655.     global useStatusBar
  656.     if {!$useStatusBar} {return [prompt $msg $def]}
  657.     if {[catch {statusPrompt "$msg ($def): "} ans]} {
  658.         error "cancel"
  659.     }
  660.     if {![string length $ans]} {return $def}
  661.     return $ans
  662. }
  663.  
  664. #================================================================================
  665. proc quoteChar {} {
  666.     message "Literal keystroke to be inserted:"
  667.     insertText [getChar]
  668. }
  669.